home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tcl8.0 / safe.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  26.2 KB  |  894 lines

  1. # safe.tcl --
  2. #
  3. # This file provide a safe loading/sourcing mechanism for safe interpreters.
  4. # It implements a virtual path mecanism to hide the real pathnames from the
  5. # slave. It runs in a master interpreter and sets up data structure and
  6. # aliases that will be invoked when used from a slave interpreter.
  7. # See the safe.n man page for details.
  8. #
  9. # Copyright (c) 1996-1997 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14. # SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20
  15.  
  16. #
  17. # The implementation is based on namespaces. These naming conventions
  18. # are followed:
  19. # Private procs starts with uppercase.
  20. # Public  procs are exported and starts with lowercase
  21. #
  22.  
  23. # Needed utilities package
  24. package require opt 0.2;
  25.  
  26. # Create the safe namespace
  27. namespace eval ::safe {
  28.  
  29.     # Exported API:
  30.     namespace export interpCreate interpInit interpConfigure interpDelete \
  31.         interpAddToAccessPath interpFindInAccessPath \
  32.         setLogCmd ;
  33.  
  34. # Proto/dummy declarations for auto_mkIndex
  35. proc ::safe::interpCreate {} {}
  36. proc ::safe::interpInit {} {}
  37. proc ::safe::interpConfigure {} {}
  38.  
  39.  
  40.     ####
  41.     #
  42.     # Setup the arguments parsing
  43.     #
  44.     ####
  45.  
  46.     # Share the descriptions
  47.     set temp [::tcl::OptKeyRegister {
  48.     {-accessPath -list {} "access path for the slave"}
  49.     {-noStatics "prevent loading of statically linked pkgs"}
  50.     {-statics true "loading of statically linked pkgs"}
  51.     {-nestedLoadOk "allow nested loading"}
  52.     {-nested false "nested loading"}
  53.     {-deleteHook -script {} "delete hook"}
  54.     }]
  55.  
  56.     # create case (slave is optional)
  57.     ::tcl::OptKeyRegister {
  58.     {?slave? -name {} "name of the slave (optional)"}
  59.     } ::safe::interpCreate ;
  60.     # adding the flags sub programs to the command program
  61.     # (relying on Opt's internal implementation details)
  62.     lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp);
  63.  
  64.     # init and configure (slave is needed)
  65.     ::tcl::OptKeyRegister {
  66.     {slave -name {} "name of the slave"}
  67.     } ::safe::interpIC;
  68.     # adding the flags sub programs to the command program
  69.     # (relying on Opt's internal implementation details)
  70.     lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp);
  71.     # temp not needed anymore
  72.     ::tcl::OptKeyDelete $temp;
  73.  
  74.  
  75.     # Helper function to resolve the dual way of specifying staticsok
  76.     # (either by -noStatics or -statics 0)
  77.     proc InterpStatics {} {
  78.     foreach v {Args statics noStatics} {
  79.         upvar $v $v
  80.     }
  81.     set flag [::tcl::OptProcArgGiven -noStatics];
  82.     if {$flag && ($noStatics == $statics) 
  83.               && ([::tcl::OptProcArgGiven -statics])} {
  84.         return -code error\
  85.             "conflicting values given for -statics and -noStatics";
  86.     }
  87.     if {$flag} {
  88.         return [expr {!$noStatics}];
  89.     } else {
  90.         return $statics
  91.     }
  92.     }
  93.  
  94.     # Helper function to resolve the dual way of specifying nested loading
  95.     # (either by -nestedLoadOk or -nested 1)
  96.     proc InterpNested {} {
  97.     foreach v {Args nested nestedLoadOk} {
  98.         upvar $v $v
  99.     }
  100.     set flag [::tcl::OptProcArgGiven -nestedLoadOk];
  101.     # note that the test here is the opposite of the "InterpStatics"
  102.     # one (it is not -noNested... because of the wanted default value)
  103.     if {$flag && ($nestedLoadOk != $nested) 
  104.               && ([::tcl::OptProcArgGiven -nested])} {
  105.         return -code error\
  106.             "conflicting values given for -nested and -nestedLoadOk";
  107.     }
  108.     if {$flag} {
  109.         # another difference with "InterpStatics"
  110.         return $nestedLoadOk
  111.     } else {
  112.         return $nested
  113.     }
  114.     }
  115.  
  116.     ####
  117.     #
  118.     #  API entry points that needs argument parsing :
  119.     #
  120.     ####
  121.  
  122.  
  123.     # Interface/entry point function and front end for "Create"
  124.     proc interpCreate {args} {
  125.     set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
  126.     InterpCreate $slave $accessPath \
  127.         [InterpStatics] [InterpNested] $deleteHook;
  128.     }
  129.  
  130.     proc interpInit {args} {
  131.     set Args [::tcl::OptKeyParse ::safe::interpIC $args]
  132.     if {![::interp exists $slave]} {
  133.         return -code error \
  134.             "\"$slave\" is not an interpreter";
  135.     }
  136.     InterpInit $slave $accessPath \
  137.         [InterpStatics] [InterpNested] $deleteHook;
  138.     }
  139.  
  140.     proc CheckInterp {slave} {
  141.     if {![IsInterp $slave]} {
  142.         return -code error \
  143.             "\"$slave\" is not an interpreter managed by ::safe::" ;
  144.     }
  145.     }
  146.  
  147.     # Interface/entry point function and front end for "Configure"
  148.     # This code is awfully pedestrian because it would need
  149.     # more coupling and support between the way we store the
  150.     # configuration values in safe::interp's and the Opt package
  151.     # Obviously we would like an OptConfigure
  152.     # to avoid duplicating all this code everywhere. -> TODO
  153.     # (the app should share or access easily the program/value
  154.     #  stored by opt)
  155.     # This is even more complicated by the boolean flags with no values
  156.     # that we had the bad idea to support for the sake of user simplicity
  157.     # in create/init but which makes life hard in configure...
  158.     # So this will be hopefully written and some integrated with opt1.0
  159.     # (hopefully for tcl8.1 ?)
  160.     proc interpConfigure {args} {
  161.     switch [llength $args] {
  162.         1 {
  163.         # If we have exactly 1 argument
  164.         # the semantic is to return all the current configuration
  165.         # We still call OptKeyParse though we know that "slave"
  166.         # is our given argument because it also checks
  167.         # for the "-help" option.
  168.         set Args [::tcl::OptKeyParse ::safe::interpIC $args];
  169.         CheckInterp $slave;
  170.         set res {}
  171.         lappend res [list -accessPath [Set [PathListName $slave]]]
  172.         lappend res [list -statics    [Set [StaticsOkName $slave]]]
  173.         lappend res [list -nested     [Set [NestedOkName $slave]]]
  174.         lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
  175.         join $res
  176.         }
  177.         2 {
  178.         # If we have exactly 2 arguments
  179.         # the semantic is a "configure get"
  180.         ::tcl::Lassign $args slave arg;
  181.         # get the flag sub program (we 'know' about Opt's internal
  182.         # representation of data)
  183.         set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
  184.         set hits [::tcl::OptHits desc $arg];
  185.                 if {$hits > 1} {
  186.                     return -code error [::tcl::OptAmbigous $desc $arg]
  187.                 } elseif {$hits == 0} {
  188.                     return -code error [::tcl::OptFlagUsage $desc $arg]
  189.                 }
  190.         CheckInterp $slave;
  191.         set item [::tcl::OptCurDesc $desc];
  192.         set name [::tcl::OptName $item];
  193.         switch -exact -- $name {
  194.             -accessPath {
  195.             return [list -accessPath [Set [PathListName $slave]]]
  196.             }
  197.             -statics {
  198.             return [list -statics    [Set [StaticsOkName $slave]]]
  199.             }
  200.             -nested {
  201.             return [list -nested     [Set [NestedOkName $slave]]]
  202.             }
  203.             -deleteHook {
  204.             return [list -deleteHook [Set [DeleteHookName $slave]]]
  205.             }
  206.             -noStatics {
  207.             # it is most probably a set in fact
  208.             # but we would need then to jump to the set part
  209.             # and it is not *sure* that it is a set action
  210.             # that the user want, so force it to use the
  211.             # unambigous -statics ?value? instead:
  212.             return -code error\
  213.                 "ambigous query (get or set -noStatics ?)\
  214.                 use -statics instead";
  215.             }
  216.             -nestedLoadOk {
  217.             return -code error\
  218.                 "ambigous query (get or set -nestedLoadOk ?)\
  219.                 use -nested instead";
  220.             }
  221.             default {
  222.             return -code error "unknown flag $name (bug)";
  223.             }
  224.         }
  225.         }
  226.         default {
  227.         # Otherwise we want to parse the arguments like init and create
  228.         # did
  229.         set Args [::tcl::OptKeyParse ::safe::interpIC $args];
  230.         CheckInterp $slave;
  231.         # Get the current (and not the default) values of
  232.         # whatever has not been given:
  233.         if {![::tcl::OptProcArgGiven -accessPath]} {
  234.             set doreset 1
  235.             set accessPath [Set [PathListName $slave]]
  236.         } else {
  237.             set doreset 0
  238.         }
  239.         if {    (![::tcl::OptProcArgGiven -statics]) 
  240.                      && (![::tcl::OptProcArgGiven -noStatics]) } {
  241.             set statics    [Set [StaticsOkName $slave]]
  242.         } else {
  243.             set statics    [InterpStatics]
  244.         }
  245.         if {    ([::tcl::OptProcArgGiven -nested]) 
  246.                      || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
  247.             set nested     [InterpNested]
  248.         } else {
  249.             set nested     [Set [NestedOkName $slave]]
  250.         }
  251.         if {![::tcl::OptProcArgGiven -deleteHook]} {
  252.             set deleteHook [Set [DeleteHookName $slave]]
  253.         }
  254.         # we can now reconfigure :
  255.         InterpSetConfig $slave $accessPath \
  256.             $statics $nested $deleteHook;
  257.         # auto_reset the slave (to completly synch the new access_path)
  258.         if {$doreset} {
  259.             if {[catch {::interp eval $slave {auto_reset}} msg]} {
  260.             Log $slave "auto_reset failed: $msg";
  261.             } else {
  262.             Log $slave "successful auto_reset" NOTICE;
  263.             }
  264.         }
  265.         }
  266.     }
  267.     }
  268.  
  269.  
  270.     ####
  271.     #
  272.     #  Functions that actually implements the exported APIs
  273.     #
  274.     ####
  275.  
  276.  
  277.     #
  278.     # safe::InterpCreate : doing the real job
  279.     #
  280.     # This procedure creates a safe slave and initializes it with the
  281.     # safe base aliases.
  282.     # NB: slave name must be simple alphanumeric string, no spaces,
  283.     # no (), no {},...  {because the state array is stored as part of the name}
  284.     #
  285.     # Returns the slave name.
  286.     #
  287.     # Optional Arguments : 
  288.     # + slave name : if empty, generated name will be used
  289.     # + access_path: path list controlling where load/source can occur,
  290.     #                if empty: the master auto_path will be used.
  291.     # + staticsok  : flag, if 0 :no static package can be loaded (load {} Xxx)
  292.     #                      if 1 :static packages are ok.
  293.     # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
  294.     #                      if 1 : multiple levels are ok.
  295.     
  296.     # use the full name and no indent so auto_mkIndex can find us
  297.     proc ::safe::InterpCreate {
  298.     slave 
  299.     access_path
  300.     staticsok
  301.     nestedok
  302.     deletehook
  303.     } {
  304.     # Create the slave.
  305.     if {[string compare "" $slave]} {
  306.         ::interp create -safe $slave;
  307.     } else {
  308.         # empty argument: generate slave name
  309.         set slave [::interp create -safe];
  310.     }
  311.     Log $slave "Created" NOTICE;
  312.  
  313.     # Initialize it. (returns slave name)
  314.     InterpInit $slave $access_path $staticsok $nestedok $deletehook;
  315.     }
  316.  
  317.  
  318.     #
  319.     # InterpSetConfig (was setAccessPath) :
  320.     #    Sets up slave virtual auto_path and corresponding structure
  321.     #    within the master. Also sets the tcl_library in the slave
  322.     #    to be the first directory in the path.
  323.     #    Nb: If you change the path after the slave has been initialized
  324.     #    you probably need to call "auto_reset" in the slave in order that it
  325.     #    gets the right auto_index() array values.
  326.  
  327.     proc ::safe::InterpSetConfig {slave access_path staticsok\
  328.         nestedok deletehook} {
  329.  
  330.     # determine and store the access path if empty
  331.     if {[string match "" $access_path]} {
  332.         set access_path [uplevel #0 set auto_path];
  333.         # Make sure that tcl_library is in auto_path
  334.         # and at the first position (needed by setAccessPath)
  335.         set where [lsearch -exact $access_path [info library]];
  336.         if {$where == -1} {
  337.         # not found, add it.
  338.         set access_path [concat [list [info library]] $access_path];
  339.         Log $slave "tcl_library was not in auto_path,\
  340.             added it to slave's access_path" NOTICE;
  341.         } elseif {$where != 0} {
  342.         # not first, move it first
  343.         set access_path [concat [list [info library]]\
  344.             [lreplace $access_path $where $where]];
  345.         Log $slave "tcl_libray was not in first in auto_path,\
  346.             moved it to front of slave's access_path" NOTICE;
  347.         
  348.         }
  349.  
  350.         # Add 1st level sub dirs (will searched by auto loading from tcl
  351.         # code in the slave using glob and thus fail, so we add them
  352.         # here so by default it works the same).
  353.         set access_path [AddSubDirs $access_path];
  354.     }
  355.  
  356.     Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
  357.         nestedok=$nestedok deletehook=($deletehook)" NOTICE;
  358.  
  359.     # clear old autopath if it existed
  360.     set nname [PathNumberName $slave];
  361.     if {[Exists $nname]} {
  362.         set n [Set $nname];
  363.         for {set i 0} {$i<$n} {incr i} {
  364.         Unset [PathToken $i $slave];
  365.         }
  366.     }
  367.  
  368.     # build new one
  369.     set slave_auto_path {}
  370.     set i 0;
  371.     foreach dir $access_path {
  372.         Set [PathToken $i $slave] $dir;
  373.         lappend slave_auto_path "\$[PathToken $i]";
  374.         incr i;
  375.     }
  376.     Set $nname $i;
  377.     Set [PathListName $slave] $access_path;
  378.     Set [VirtualPathListName $slave] $slave_auto_path;
  379.  
  380.     Set [StaticsOkName $slave] $staticsok
  381.     Set [NestedOkName $slave] $nestedok
  382.     Set [DeleteHookName $slave] $deletehook
  383.  
  384.     SyncAccessPath $slave;
  385.     }
  386.  
  387.     #
  388.     #
  389.     # FindInAccessPath:
  390.     #    Search for a real directory and returns its virtual Id
  391.     #    (including the "$")
  392. proc ::safe::interpFindInAccessPath {slave path} {
  393.     set access_path [GetAccessPath $slave];
  394.     set where [lsearch -exact $access_path $path];
  395.     if {$where == -1} {
  396.         return -code error "$path not found in access path $access_path";
  397.     }
  398.     return "\$[PathToken $where]";
  399.     }
  400.  
  401.     #
  402.     # addToAccessPath:
  403.     #    add (if needed) a real directory to access path
  404.     #    and return its virtual token (including the "$").
  405. proc ::safe::interpAddToAccessPath {slave path} {
  406.     # first check if the directory is already in there
  407.     if {![catch {interpFindInAccessPath $slave $path} res]} {
  408.         return $res;
  409.     }
  410.     # new one, add it:
  411.     set nname [PathNumberName $slave];
  412.     set n [Set $nname];
  413.     Set [PathToken $n $slave] $path;
  414.  
  415.     set token "\$[PathToken $n]";
  416.  
  417.     Lappend [VirtualPathListName $slave] $token;
  418.     Lappend [PathListName $slave] $path;
  419.     Set $nname [expr $n+1];
  420.  
  421.     SyncAccessPath $slave;
  422.  
  423.     return $token;
  424.     }
  425.  
  426.     # This procedure applies the initializations to an already existing
  427.     # interpreter. It is useful when you want to install the safe base
  428.     # aliases into a preexisting safe interpreter.
  429.     proc ::safe::InterpInit {
  430.     slave 
  431.     access_path
  432.     staticsok
  433.     nestedok
  434.     deletehook
  435.     } {
  436.  
  437.     # Configure will generate an access_path when access_path is
  438.     # empty.
  439.     InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook;
  440.  
  441.     # These aliases let the slave load files to define new commands
  442.  
  443.     # NB we need to add [namespace current], aliases are always
  444.     # absolute paths.
  445.     ::interp alias $slave source {} [namespace current]::AliasSource $slave
  446.     ::interp alias $slave load {} [namespace current]::AliasLoad $slave
  447.  
  448.     # This alias lets the slave have access to a subset of the 'file'
  449.     # command functionality.
  450.  
  451.     AliasSubset $slave file file dir.* join root.* ext.* tail \
  452.         path.* split
  453.  
  454.     # This alias interposes on the 'exit' command and cleanly terminates
  455.     # the slave.
  456.  
  457.     ::interp alias $slave exit {} [namespace current]::interpDelete $slave
  458.  
  459.     # The allowed slave variables already have been set
  460.     # by Tcl_MakeSafe(3)
  461.  
  462.  
  463.     # Source init.tcl into the slave, to get auto_load and other
  464.     # procedures defined:
  465.  
  466.     # We don't try to use the -rsrc on the mac because it would get
  467.     # confusing if you would want to customize init.tcl
  468.     # for a given set of safe slaves, on all the platforms
  469.     # you just need to give a specific access_path and
  470.     # the mac should be no exception. As there is no
  471.     # obvious full "safe ressources" design nor implementation
  472.     # for the mac, safe interps there will just don't
  473.     # have that ability. (A specific app can still reenable
  474.     # that using custom aliases if they want to).
  475.     # It would also make the security analysis and the Safe Tcl security
  476.     # model platform dependant and thus more error prone.
  477.  
  478.     if {[catch {::interp eval $slave\
  479.         {source [file join $tcl_library init.tcl]}}\
  480.         msg]} {
  481.         Log $slave "can't source init.tcl ($msg)";
  482.         error "can't source init.tcl into slave $slave ($msg)"
  483.     }
  484.  
  485.     return $slave
  486.     }
  487.  
  488.  
  489.     # Add (only if needed, avoid duplicates) 1 level of
  490.     # sub directories to an existing path list.
  491.     # Also removes non directories from the returned list.
  492.     proc AddSubDirs {pathList} {
  493.     set res {}
  494.     foreach dir $pathList {
  495.         if {[file isdirectory $dir]} {
  496.         # check that we don't have it yet as a children
  497.         # of a previous dir
  498.         if {[lsearch -exact $res $dir]<0} {
  499.             lappend res $dir;
  500.         }
  501.         foreach sub [glob -nocomplain -- [file join $dir *]] {
  502.             if {    ([file isdirectory $sub])
  503.                  && ([lsearch -exact $res $sub]<0) } {
  504.             # new sub dir, add it !
  505.                     lappend res $sub;
  506.                 }
  507.         }
  508.         }
  509.     }
  510.     return $res;
  511.     }
  512.  
  513.     # This procedure deletes a safe slave managed by Safe Tcl and
  514.     # cleans up associated state:
  515.  
  516. proc ::safe::interpDelete {slave} {
  517.  
  518.         Log $slave "About to delete" NOTICE;
  519.  
  520.     # If the slave has a cleanup hook registered, call it.
  521.     # check the existance because we might be called to delete an interp
  522.     # which has not been registered with us at all
  523.     set hookname [DeleteHookName $slave];
  524.     if {[Exists $hookname]} {
  525.         set hook [Set $hookname];
  526.         if {![::tcl::Lempty $hook]} {
  527.         # remove the hook now, otherwise if the hook
  528.         # calls us somehow, we'll loop
  529.         Unset $hookname;
  530.         if {[catch {eval $hook $slave} err]} {
  531.             Log $slave "Delete hook error ($err)";
  532.         }
  533.         }
  534.     }
  535.  
  536.     # Discard the global array of state associated with the slave, and
  537.     # delete the interpreter.
  538.  
  539.     set statename [InterpStateName $slave];
  540.     if {[Exists $statename]} {
  541.         Unset $statename;
  542.     }
  543.  
  544.     # if we have been called twice, the interp might have been deleted
  545.     # already
  546.     if {[::interp exists $slave]} {
  547.         ::interp delete $slave;
  548.         Log $slave "Deleted" NOTICE;
  549.     }
  550.  
  551.     return
  552.     }
  553.  
  554.     # Set (or get) the loging mecanism 
  555.  
  556. proc ::safe::setLogCmd {args} {
  557.     variable Log;
  558.     if {[llength $args] == 0} {
  559.     return $Log;
  560.     } else {
  561.     if {[llength $args] == 1} {
  562.         set Log [lindex $args 0];
  563.     } else {
  564.         set Log $args
  565.     }
  566.     }
  567. }
  568.  
  569.     # internal variable
  570.     variable Log {}
  571.  
  572.     # ------------------- END OF PUBLIC METHODS ------------
  573.  
  574.  
  575.     #
  576.     # sets the slave auto_path to the master recorded value.
  577.     # also sets tcl_library to the first token of the virtual path.
  578.     #
  579.     proc SyncAccessPath {slave} {
  580.     set slave_auto_path [Set [VirtualPathListName $slave]];
  581.     ::interp eval $slave [list set auto_path $slave_auto_path];
  582.     Log $slave \
  583.         "auto_path in $slave has been set to $slave_auto_path"\
  584.         NOTICE;
  585.     ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]];
  586.     }
  587.  
  588.     # base name for storing all the slave states
  589.     # the array variable name for slave foo is thus "Sfoo"
  590.     # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
  591.     # ok everywhere (or should))
  592.     # We add the S prefix to avoid that a slave interp called "Log"
  593.     # would smash our "Log" variable.
  594.     proc InterpStateName {slave} {
  595.     return "S$slave";
  596.     }
  597.  
  598.     # Check that the given slave is "one of us"
  599.     proc IsInterp {slave} {
  600.     expr {    ([Exists [InterpStateName $slave]]) 
  601.            && ([::interp exists $slave])}
  602.     }
  603.  
  604.     # returns the virtual token for directory number N
  605.     # if the slave argument is given, 
  606.     # it will return the corresponding master global variable name
  607.     proc PathToken {n {slave ""}} {
  608.     if {[string compare "" $slave]} {
  609.         return "[InterpStateName $slave](access_path,$n)";
  610.     } else {
  611.         # We need to have a ":" in the token string so
  612.         # [file join] on the mac won't turn it into a relative
  613.         # path.
  614.         return "p(:$n:)";
  615.     }
  616.     }
  617.     # returns the variable name of the complete path list
  618.     proc PathListName {slave} {
  619.     return "[InterpStateName $slave](access_path)";
  620.     }
  621.     # returns the variable name of the complete path list
  622.     proc VirtualPathListName {slave} {
  623.     return "[InterpStateName $slave](access_path_slave)";
  624.     }
  625.     # returns the variable name of the number of items
  626.     proc PathNumberName {slave} {
  627.     return "[InterpStateName $slave](access_path,n)";
  628.     }
  629.     # returns the staticsok flag var name
  630.     proc StaticsOkName {slave} {
  631.     return "[InterpStateName $slave](staticsok)";
  632.     }
  633.     # returns the nestedok flag var name
  634.     proc NestedOkName {slave} {
  635.     return "[InterpStateName $slave](nestedok)";
  636.     }
  637.     # Run some code at the namespace toplevel
  638.     proc Toplevel {args} {
  639.     namespace eval [namespace current] $args;
  640.     }
  641.     # set/get values
  642.     proc Set {args} {
  643.     eval Toplevel set $args;
  644.     }
  645.     # lappend on toplevel vars
  646.     proc Lappend {args} {
  647.     eval Toplevel lappend $args;
  648.     }
  649.     # unset a var/token (currently just an global level eval)
  650.     proc Unset {args} {
  651.     eval Toplevel unset $args;
  652.     }
  653.     # test existance 
  654.     proc Exists {varname} {
  655.     Toplevel info exists $varname;
  656.     }
  657.     # short cut for access path getting
  658.     proc GetAccessPath {slave} {
  659.     Set [PathListName $slave]
  660.     }
  661.     # short cut for statics ok flag getting
  662.     proc StaticsOk {slave} {
  663.     Set [StaticsOkName $slave]
  664.     }
  665.     # short cut for getting the multiples interps sub loading ok flag
  666.     proc NestedOk {slave} {
  667.     Set [NestedOkName $slave]
  668.     }
  669.     # interp deletion storing hook name
  670.     proc DeleteHookName {slave} {
  671.     return [InterpStateName $slave](cleanupHook)
  672.     }
  673.  
  674.     #
  675.     # translate virtual path into real path
  676.     #
  677.     proc TranslatePath {slave path} {
  678.     # somehow strip the namespaces 'functionality' out (the danger
  679.     # is that we would strip valid macintosh "../" queries... :
  680.     if {[regexp {(::)|(\.\.)} $path]} {
  681.         error "invalid characters in path $path";
  682.     }
  683.     set n [expr [Set [PathNumberName $slave]]-1];
  684.     for {} {$n>=0} {incr n -1} {
  685.         # fill the token virtual names with their real value
  686.         set [PathToken $n] [Set [PathToken $n $slave]];
  687.     }
  688.     # replaces the token by their value
  689.     subst -nobackslashes -nocommands $path;
  690.     }
  691.  
  692.  
  693.     # Log eventually log an error
  694.     # to enable error logging, set Log to {puts stderr} for instance
  695.     proc Log {slave msg {type ERROR}} {
  696.     variable Log;
  697.     if {[info exists Log] && [llength $Log]} {
  698.         eval $Log [list "$type for slave $slave : $msg"];
  699.     }
  700.     }
  701.  
  702.     
  703.     # file name control (limit access to files/ressources that should be
  704.     # a valid tcl source file)
  705.     proc CheckFileName {slave file} {
  706.     # limit what can be sourced to .tcl
  707.     # and forbid files with more than 1 dot and
  708.     # longer than 14 chars
  709.     set ftail [file tail $file];
  710.     if {[string length $ftail]>14} {
  711.         error "$ftail: filename too long";
  712.     }
  713.     if {[regexp {\..*\.} $ftail]} {
  714.         error "$ftail: more than one dot is forbidden";
  715.     }
  716.     if {[string compare $ftail "tclIndex"] && \
  717.         [string compare [string tolower [file extension $ftail]]\
  718.         ".tcl"]} {
  719.         error "$ftail: must be a *.tcl or tclIndex";
  720.     }
  721.  
  722.     if {![file exists $file]} {
  723.         # don't tell the file path
  724.         error "no such file or directory";
  725.     }
  726.  
  727.     if {![file readable $file]} {
  728.         # don't tell the file path
  729.         error "not readable";
  730.     }
  731.  
  732.     }
  733.  
  734.  
  735.     # AliasSource is the target of the "source" alias in safe interpreters.
  736.  
  737.     proc AliasSource {slave args} {
  738.  
  739.     set argc [llength $args];
  740.     # Allow only "source filename"
  741.     # (and not mac specific -rsrc for instance - see comment in ::init
  742.     # for current rationale)
  743.     if {$argc != 1} {
  744.         set msg "wrong # args: should be \"source fileName\""
  745.         Log $slave "$msg ($args)";
  746.         return -code error $msg;
  747.     }
  748.     set file [lindex $args 0]
  749.     
  750.     # get the real path from the virtual one.
  751.     if {[catch {set file [TranslatePath $slave $file]} msg]} {
  752.         Log $slave $msg;
  753.         return -code error "permission denied"
  754.     }
  755.     
  756.     # check that the path is in the access path of that slave
  757.     if {[catch {FileInAccessPath $slave $file} msg]} {
  758.         Log $slave $msg;
  759.         return -code error "permission denied"
  760.     }
  761.  
  762.     # do the checks on the filename :
  763.     if {[catch {CheckFileName $slave $file} msg]} {
  764.         Log $slave "$file:$msg";
  765.         return -code error $msg;
  766.     }
  767.  
  768.     # passed all the tests , lets source it:
  769.     if {[catch {::interp invokehidden $slave source $file} msg]} {
  770.         Log $slave $msg;
  771.         return -code error "script error";
  772.     }
  773.     return $msg
  774.     }
  775.  
  776.     # AliasLoad is the target of the "load" alias in safe interpreters.
  777.  
  778.     proc AliasLoad {slave file args} {
  779.  
  780.     set argc [llength $args];
  781.     if {$argc > 2} {
  782.         set msg "load error: too many arguments";
  783.         Log $slave "$msg ($argc) {$file $args}";
  784.         return -code error $msg;
  785.     }
  786.  
  787.     # package name (can be empty if file is not).
  788.     set package [lindex $args 0];
  789.  
  790.     # Determine where to load. load use a relative interp path
  791.     # and {} means self, so we can directly and safely use passed arg.
  792.     set target [lindex $args 1];
  793.     if {[string length $target]} {
  794.         # we will try to load into a sub sub interp
  795.         # check that we want to authorize that.
  796.         if {![NestedOk $slave]} {
  797.         Log $slave "loading to a sub interp (nestedok)\
  798.             disabled (trying to load $package to $target)";
  799.         return -code error "permission denied (nested load)";
  800.         }
  801.         
  802.     }
  803.  
  804.     # Determine what kind of load is requested
  805.     if {[string length $file] == 0} {
  806.         # static package loading
  807.         if {[string length $package] == 0} {
  808.         set msg "load error: empty filename and no package name";
  809.         Log $slave $msg;
  810.         return -code error $msg;
  811.         }
  812.         if {![StaticsOk $slave]} {
  813.         Log $slave "static packages loading disabled\
  814.             (trying to load $package to $target)";
  815.         return -code error "permission denied (static package)";
  816.         }
  817.     } else {
  818.         # file loading
  819.  
  820.         # get the real path from the virtual one.
  821.         if {[catch {set file [TranslatePath $slave $file]} msg]} {
  822.         Log $slave $msg;
  823.         return -code error "permission denied"
  824.         }
  825.  
  826.         # check the translated path
  827.         if {[catch {FileInAccessPath $slave $file} msg]} {
  828.         Log $slave $msg;
  829.         return -code error "permission denied (path)"
  830.         }
  831.     }
  832.  
  833.     if {[catch {::interp invokehidden\
  834.         $slave load $file $package $target} msg]} {
  835.         Log $slave $msg;
  836.         return -code error $msg
  837.     }
  838.  
  839.     return $msg
  840.     }
  841.  
  842.     # FileInAccessPath raises an error if the file is not found in
  843.     # the list of directories contained in the (master side recorded) slave's
  844.     # access path.
  845.  
  846.     # the security here relies on "file dirname" answering the proper
  847.     # result.... needs checking ?
  848.     proc FileInAccessPath {slave file} {
  849.  
  850.     set access_path [GetAccessPath $slave];
  851.  
  852.     if {[file isdirectory $file]} {
  853.         error "\"$file\": is a directory"
  854.     }
  855.     set parent [file dirname $file]
  856.     if {[lsearch -exact $access_path $parent] == -1} {
  857.         error "\"$file\": not in access_path";
  858.     }
  859.     }
  860.  
  861.     # This procedure enables access from a safe interpreter to only a subset of
  862.     # the subcommands of a command:
  863.  
  864.     proc Subset {slave command okpat args} {
  865.     set subcommand [lindex $args 0]
  866.     if {[regexp $okpat $subcommand]} {
  867.         return [eval {$command $subcommand} [lrange $args 1 end]]
  868.     }
  869.     set msg "not allowed to invoke subcommand $subcommand of $command";
  870.     Log $slave $msg;
  871.     error $msg;
  872.     }
  873.  
  874.     # This procedure installs an alias in a slave that invokes "safesubset"
  875.     # in the master to execute allowed subcommands. It precomputes the pattern
  876.     # of allowed subcommands; you can use wildcards in the pattern if you wish
  877.     # to allow subcommand abbreviation.
  878.     #
  879.     # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
  880.  
  881.     proc AliasSubset {slave alias target args} {
  882.     set pat ^(; set sep ""
  883.     foreach sub $args {
  884.         append pat $sep$sub
  885.         set sep |
  886.     }
  887.     append pat )\$
  888.     ::interp alias $slave $alias {}\
  889.         [namespace current]::Subset $slave $target $pat
  890.     }
  891.  
  892. }
  893.